home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / clue.lha / clue / events.l < prev    next >
Text File  |  1989-07-12  |  69KB  |  1,802 lines
  1. ;;; -*- Mode:Lisp; Package:CLUEI; Syntax:COMMON-LISP; Base:10; Lowercase:T -*-
  2.  
  3. ;;;
  4. ;;;             TEXAS INSTRUMENTS INCORPORATED
  5. ;;;                  P.O. BOX 2909
  6. ;;;                   AUSTIN, TEXAS 78769
  7. ;;;
  8. ;;; Copyright (C) 1987 Texas Instruments Incorporated.
  9. ;;;
  10. ;;; Permission is granted to any individual or institution to use, copy, modify,
  11. ;;; and distribute this software, provided that this complete copyright and
  12. ;;; permission notice is maintained, intact, in all copies and supporting
  13. ;;; documentation.
  14. ;;;
  15. ;;; Texas Instruments Incorporated provides this software "as is" without
  16. ;;; express or implied warranty.
  17. ;;;
  18.  
  19. #| To Do:
  20.  
  21. 1. Hooks are in place to handle button mult-click and hold using 3 extra modifier state bits
  22.    (:hold :click :double), but the interface isn't there yet.
  23.  
  24. 2. Add translation from symbolic mouse button names to actual mouse button/modifier specs.
  25.    Use the keysym translation facilities (define 5 keysyms for each of the mouse keys,
  26.    and use define-keysym)
  27.  
  28. |#
  29.  
  30. (in-package 'cluei :use '(lisp xlib))
  31.  
  32. (export '( event
  33.       ;; Event slots
  34.       key display contact character keysym above-sibling
  35.       atom border-width child code colormap configure-p count data
  36.       drawable event-window focus-p format height hint-p installed-p
  37.       keymap kind major minor mode name new-p override-redirect-p
  38.       parent place property requestor root root-x root-y same-screen-p
  39.       selection send-event-p state target time type width window x y
  40.  
  41.       mode-type             
  42.       *remap-events*
  43.       *restrict-events*
  44.       add-mode
  45.       delete-mode
  46.       with-mode
  47.       with-event-mode
  48.       contact-mode
  49.       contact-super-mode
  50.  
  51.       apply-action
  52.       call-action
  53.       defaction
  54.       describe-action
  55.       eval-action
  56.       ignore-action
  57.       inside-contact-p
  58.       perform-callback
  59.       throw-action
  60.       trace-action
  61.       with-event
  62.       
  63.       add-before-action
  64.       delete-before-action
  65.       process-all-events
  66.       process-next-event
  67.       handle-event
  68.       translate-event
  69.       check-function
  70.       defevent
  71.       undefevent
  72.       event-actions
  73.       add-event
  74.       delete-event
  75.       describe-event-translations
  76.       add-timer
  77.       delete-timer
  78.       ))
  79.  
  80. ;; INPUT PROCESSING
  81.  
  82. ;; Rather than pass around event parameters in long plists,
  83. ;; parameters are stuffed into this structure.  For any one event,
  84. ;; most slots are undefined, and these are initialized to NIL.
  85. ;; Event structures are kept on a resource and re-used.
  86. ;; The only reason event is a class and not a structure is because
  87. ;; we want to use with-slots.
  88.  
  89. (defclass event ()
  90.   ((key)                    ; Event key
  91.    (display)                    ; Display event was reported to
  92.    (contact)                    ; Contact the event is directed to
  93.    (character)                    ; character from code and state
  94.    (keysym)                    ; keysym from code and state
  95.    (plist :initform nil :type list)        ; Place for extension data
  96.    ;; The following are from the CLX event
  97.    (above-sibling)                ; Used by :configure-notify :configure-request
  98.    (atom)                    ; Used by :property-notify 
  99.    (border-width)                ; Used by :create-notify :configure-notify :configure-request
  100.    (child)                    ; Used by :key-press :key-release :button-press :button-release
  101.                         ;         :motion-notify :enter-notify :leave-notify
  102.    (code)                    ; Used by :key-press :key-release :button-press :button-release
  103.    (colormap)                    ; Used by :colormap-notify
  104.    (sequence)                    ; Used by all except :keymap-notify
  105.    (configure-p)                ; Used by :unmap-notify
  106.    (count)                    ; Used by :exposure :graphics-exposure :mapping-notify
  107.    (data)                    ; Used by :client-message :timer
  108.    (drawable)                    ; Used by :graphics-exposure :no-exposure
  109.    (event-window)                ; Used by :destroy-notify :unmap-notify :map-notify :reparent-notify
  110.                         ;         :configure-notify :gravity-notify :circulate-notify
  111.    (focus-p)                    ; Used by :enter-notify :leave-notify
  112.    (format)                    ; Used by :client-message
  113.    (height)                    ; Used by :exposure :graphics-exposure :create-notify :configure-notify
  114.                         ;         :configure-request :resize-request
  115.    (hint-p)                    ; Used by :motion-notify
  116.    (installed-p)                ; Used by :colormap-notify
  117.    (keymap)                    ; Used by :keymap-notify
  118.    (kind)                    ; Used by :enter-notify :leave-notify :focus-in :focus-out
  119.    (major)                    ; Used by :graphics-exposure :no-exposure
  120.    (minor)                    ; Used by :graphics-exposure :no-exposure
  121.    (mode)                    ; Used by :enter-notify :leave-notify :focus-in :focus-out
  122.    (name)                    ; Used by :timer
  123.    (new-p)                    ; Used by :colormap-notify
  124.    (override-redirect-p)            ; Used by :create-notify :map-notify
  125.                         ;                         :reparent-notify :configure-notify
  126.    (parent)                    ; Used by :create-notify :map-request :reparent-notify :configure-request
  127.                         ;         :circulate-notify :circulate-request 
  128.    (place)                    ; Used by :circulate-notify :circulate-request
  129.    (property)                    ; Used by :selection-request :selection-notify
  130.    (requestor)                    ; Used by :selection-request
  131.    (root)                    ; Used by :key-press :key-release :button-press :button-release
  132.                         ;         :motion-notify :enter-notify :leave-notify
  133.    (root-x)                    ; Used by :key-press :key-release :button-press :button-release
  134.                         ;         :motion-notify :enter-notify :leave-notify
  135.    (root-y)                    ; Used by :key-press :key-release :button-press :button-release
  136.                         ;         :motion-notify :enter-notify :leave-notify
  137.    (same-screen-p)                ; Used by :key-press :key-release :button-press :button-release
  138.                         ;         :motion-notify :enter-notify :leave-notify
  139.    (selection)                    ; Used by :selection-clear :selection-request :selection-notify
  140.    (send-event-p)                ; Used by -all events-
  141.    (state)                    ; Used by :key-press :key-release :button-press :button-release
  142.                         ;         :motion-notify :enter-notify :leave-notify
  143.                         ;         :visibility-notify :property-notify
  144.    (target)                    ; Used by :selection-request :selection-notify
  145.    (time)                    ; Used by :key-press :key-release :button-press :button-release
  146.                         ;         :motion-notify :enter-notify :leave-notify :property-notify
  147.                         ;         :selection-clear :selection-request :selection-notify
  148.    (type)                    ; Used by :client-message
  149.    (width)                    ; Used by :exposure :graphics-exposure :create-notify :configure-notify
  150.                         ;         :configure-request :resize-request
  151.    (window)                    ; Used by all events except :graphics-exposure :no-exposure :mapping-notify
  152.    (x)                        ; Used by :key-press :key-release :button-press :button-release
  153.                         ;         :motion-notify :enter-notify :leave-notify :exposure
  154.                         ;         :graphics-exposure :create-notify :reparent-notify
  155.                         ;         :configure-notify :configure-request :gravity-notify
  156.    (y)                        ; Used by :key-press :key-release :button-press :button-release
  157.                         ;         :motion-notify :enter-notify :leave-notify :exposure
  158.                         ;         :graphics-exposure :create-notify :reparent-notify
  159.                         ;         :configure-notify :configure-request :gravity-notify
  160.   )
  161.   (:documentation "CLUE event structure, one slot for every event value.  No methods."))
  162.  
  163. (defmethod print-object ((instance event) stream)
  164.   #+lispm
  165.   (si:printing-random-object (instance stream)
  166.     (with-slots (key contact) instance
  167.       (format stream "Event ~a for ~a" key (and (typep contact 'contact) (contact-name contact)))))
  168.   #-lispm
  169.   (progn
  170.     (write-string "#<EVENT " stream)
  171.     (with-slots (key contact) instance
  172.       (princ key stream)
  173.       (when (typep contact 'contact)
  174.     (write-string " for " stream)
  175.     (princ (contact-name instance) stream)))
  176.     (write-char #\> stream)))
  177.  
  178. ;;; PROCESS-NEXT-EVENT copies event data into an event structure.  After the
  179. ;;; event is processed, its put back into *event-cache* to be re-used on the
  180. ;;; next event.  This is done to reduce consing.  Care is taken to shield the
  181. ;;; application progammer from the actual event structure to prevent saving the
  182. ;;; event structure in application data structures.  If an application did this,
  183. ;;; the event would be destructively modified on subsequent events.
  184. (defvar *event-cache* nil)
  185.  
  186. (defun allocate-event ()
  187.   ;; Get an event structure, initializing all slots to NIL
  188.   (let ((event (or (xlib::atomic-pop *event-cache*)
  189.            (make-instance 'event))))
  190.     (with-slots (key display contact character keysym plist code state time event-window
  191.              root drawable window child parent root-x root-y x y
  192.              width height border-width override-redirect-p same-screen-p
  193.              configure-p hint-p kind mode keymap focus-p count major minor
  194.              above-sibling place atom selection requestor target property
  195.              colormap new-p installed-p format type data name send-event-p
  196.              )
  197.         (the event event)        
  198.       (setf key    nil
  199.         display nil                ; Display event was reported to
  200.         contact nil                ; Contact the event is directed to
  201.         character nil            ; character from code and state
  202.         keysym nil                ; keysym from code and state
  203.         ;; The following are from the CLX event
  204.         code nil
  205.         state nil
  206.         time nil
  207.         event-window nil
  208.         root nil
  209.         drawable nil
  210.         window nil
  211.         child nil
  212.         parent nil
  213.         root-x nil
  214.         root-y nil
  215.         x nil
  216.         y nil
  217.         width nil
  218.         height nil
  219.         border-width nil
  220.         override-redirect-p nil
  221.         same-screen-p nil
  222.         configure-p nil
  223.         hint-p nil
  224.         kind nil
  225.         mode nil
  226.         keymap nil
  227.         focus-p nil
  228.         count nil
  229.         major nil
  230.         minor nil
  231.         above-sibling nil
  232.         place nil
  233.         atom nil
  234.         selection nil
  235.         requestor nil
  236.         target nil
  237.         property nil
  238.         colormap nil
  239.         new-p nil
  240.         installed-p nil
  241.         format nil
  242.         type nil
  243.         data nil
  244.         send-event-p nil
  245.         name nil
  246.         plist nil
  247.         ))
  248.     event))
  249.  
  250. (defun deallocate-event (event)
  251.   ;; Return an event to the cache, where it can be re-used.
  252.   (xlib::atomic-push event *event-cache*))
  253.  
  254.  
  255. ;;-----------------------------------------------------------------------------
  256. ;; MODES
  257.  
  258. ;;; Applications may find it necessary to establish a special input
  259. ;;; "mode" in which the user is temporarily required to direct input
  260. ;;; to one or more specific contacts. In such a mode, user input
  261. ;;; events directed to other contacts are not handled normally, but
  262. ;;; instead are either ignored or acknowledged with some kind of
  263. ;;; warning.
  264.  
  265. (deftype mode-type () '(member :non-exclusive :exclusive :spring-loaded))
  266.  
  267. (defparameter *remap-events* '(:key-press :key-release :button-press :button-release)
  268.   "These events are sent to the most recent :spring-loaded contact on the mode-stack.")
  269.  
  270. (defparameter *restrict-events*
  271.           '(:motion-notify :enter-notify :leave-notify)
  272.   "These 'user' events are sent to the restrict-action of the first
  273.    :exclusive contact on the mode-stack")
  274.  
  275. (defparameter *sensitive-events*
  276.           '(:key-press :key-release :button-press :button-release
  277.         :motion-notify :enter-notify :leave-notify
  278.         :focus-in :focus-out)
  279.   "These 'user' events are ignored by an insensitive contact.")
  280.  
  281. ;; Other events (NOT in *remap-events* or *restrict-events*) are handled normally
  282.  
  283. ;;; When dispatching *restrict-events*, if the mode-stack is non-nil,
  284. ;;; the event is restricted as follows.  For each entry of the
  285. ;;; mode-stack, if the event is for the contact on the stack, or one of
  286. ;;; its descendents, it is dispatched.  When a stack-entry with
  287. ;;; :Exclusive or :Spring-Loaded MODE-TYPE is encountered, the search
  288. ;;; stops, and the event is sent to the RESTRICT-ACTION action of the
  289. ;;; mode contact with ARGS.  If there are no :Exclusive or
  290. ;;; :Spring-Loaded contacts on the stack, the event is dispatched
  291. ;;; normally.
  292. ;;;
  293. ;;; When dispatching *remap-events*, if the mode-stack is non-nil, the
  294. ;;; event is sent (re-mapped) to the first :spring-loaded contact on the
  295. ;;; mode-stack.  If there is no :spring-loaded contact, *remap-events*
  296. ;;; are handled like *restrict-events*
  297.  
  298. (defun add-mode (contact &optional (mode-type :non-exclusive) (action 'restrict) &rest args)
  299.   "Push CONTACT with (mode-type action . args) onto the mode-stack"
  300.   (declare (type contact contact)
  301.        (type mode-type mode-type)
  302.        (type symbol action)
  303.        (type list args))
  304.   (when (and (not (eq mode-type :non-exclusive))
  305.          (not (sensitive-p contact)))
  306.     (error "ADD-MODE on insensitive contact ~s" contact))
  307.   (push (list* contact mode-type action (copy-list args))
  308.     (display-mode-stack (contact-display contact))))
  309.  
  310. (defun delete-mode (contact)
  311.   "Pop CONTACT (and everything above CONTACT) off the mode-stack
  312.    Returns T when found and removed, else NIL"
  313.   (declare (type contact contact)
  314.        (values boolean))
  315.   (let* ((display (contact-display contact))
  316.      (mode-stack (display-mode-stack display)))
  317.     (when mode-stack
  318.       (do ((stack mode-stack (cdr stack)))
  319.       ((endp stack)
  320.        ;; If contact not found, check its children
  321.        ;; This feature utilized when un-mapping the parent of a modal contact
  322.        (do ((stack mode-stack (cdr stack))
  323.         (found-p nil)
  324.         (result nil))
  325.            ((endp stack)
  326.         (when found-p
  327.           (setf (display-mode-stack display) result)
  328.           t))
  329.          (when (ancestor-p contact (caar stack))
  330.            (setq found-p t
  331.              result stack))))
  332.     (when (eq contact (caar stack))
  333.       (setf (display-mode-stack display) (cdr stack))
  334.       (return t))))))
  335.  
  336. (defmacro with-mode ((contact &key (mode-type :exclusive)
  337.                   (action 'ignore-action) args)
  338.              body-form &body cleanup-forms)
  339.   "While executing BODY-FORM, user events will only be delivered to CONTACT
  340. and its children.  Non-user events (e.g.  exposure,property-notify, etc)
  341. will be delivered normally.  User events to other contacts will cause
  342. the ACTION action for CONTACT's class to be invoked with ARGS.  The
  343. primary contact method for the default ACTION, ignore-action, beeps on
  344. *remap-events*, and ignores all others.
  345.    
  346. WITH-MODE executes BODY-FORM within an Unwind-Protect.  With-Mode
  347. returns the value of its BODY-FORM, and executes CLEANUP-FORMS before
  348. exiting. "
  349.   (let ((local-contact (gensym)))
  350.     `(let ((,local-contact ,contact))
  351.        (unwind-protect
  352.        (progn
  353.          (add-mode ,local-contact ,mode-type (function ,action) ,@args)
  354.          ,body-form)
  355.      (delete-mode ,local-contact)
  356.      ,@cleanup-forms))))
  357.    
  358. (defun contact-mode (contact)
  359.   "If contact is the descendent of a modal contact, return the modal contact, else NIL."
  360.   (let ((modes (display-mode-stack (contact-display contact))))
  361.     (if modes ;; No mode stack means EVERYTHING is in "on the stack"
  362.     (do ((p contact (contact-parent p)))
  363.         ((null p) nil)
  364.       (dolist (mode modes)
  365.         (cond ((eq p (car mode)) 
  366.            (return-from contact-mode p))
  367.           ((eq (cadr mode) :exclusive)
  368.            (return nil))))))))
  369.  
  370. (defun contact-super-mode (contact)
  371.   "If contact is the descendent of a modal contact, return the superior modal contact, else NIL."
  372.   (let ((modes (cluei::display-mode-stack (contact-display contact))))
  373.     (if modes ;; No mode stack means EVERYTHING is in "on the stack"
  374.     (do ((p contact (contact-parent p)))
  375.         ((null p) nil)
  376.       (do ((mode modes (cdr mode))
  377.            (supermode nil))
  378.           ((endp mode))
  379.         (when (eq p (caar mode))
  380.           (return-from contact-super-mode supermode))
  381.         (unless (eq (cadar mode) :non-exclusive)
  382.           (setq supermode (caar mode))))))))
  383.  
  384.  
  385. (defmacro with-event-mode ((contact &rest translations) &body body)
  386.   "The given event TRANSLATIONS are defined for the CONTACT only within
  387. the dynamic extent of the BODY. The TRANSLATIONS are processed before any
  388. other previously-defined instance or class translations for CONTACT."
  389.   (let ((previous-actions (gensym))
  390.     (new-translations (gensym))
  391.     (translation      (gensym))
  392.     (previous         (gensym)))
  393.  
  394.   `(let* ((,new-translations (list ,@translations))
  395.       (,previous-actions
  396.        ;; Save any actions from previous instance translations for these event specs
  397.        (let (pa)
  398.          (dolist (,translation ,new-translations (nreverse pa))
  399.            (push (assoc (car (parse-event-spec ,translation))
  400.                 (slot-value (the contact ,contact) 'event-translations)
  401.                 :test #'equal)
  402.              pa)))))
  403.  
  404.      ;; Add modal translations
  405.      (dolist (,translation ,new-translations)
  406.        (apply #'add-event ,contact ,translation))
  407.      
  408.  
  409.      (unwind-protect
  410.      (progn
  411.        ,@body)
  412.        
  413.        ;; Delete modal translations and restore any previous ones
  414.        (dolist (,translation ,new-translations)
  415.      (let ((,previous (pop ,previous-actions)))
  416.        (if ,previous
  417.            (apply #'add-event ,contact (first ,translation) ,previous)
  418.            (delete-event ,contact (first ,translation)))))))))
  419.  
  420.  
  421.  
  422.  
  423. ;;;-----------------------------------------------------------------------------
  424. ;;; Actions
  425.  
  426.  
  427. ;; Retained temporarily for compatibility purposes
  428. (defmacro defaction (name lambda-list &body body)
  429.   "Define an action method. THIS MACRO IS NOW OBSOLETE. Just use defmethod."
  430.   (let (qualifier self)
  431.     
  432.     ;; Handle method qualifiers (:before or :after)
  433.     (when (atom lambda-list)
  434.       (setq qualifier   (list lambda-list)
  435.         lambda-list (pop body)))
  436.     
  437.     ;; Get the first specialized parameter in the lambda-list
  438.     (dolist (arg lambda-list)
  439.       (when (member arg lambda-list-keywords) (return nil))
  440.       (when (consp arg)
  441.     (setf self (first arg))))
  442.     
  443.     `(progn              
  444.        (compiler-let (($contact$ ',self))    ; Hook for call-action
  445.      (defmethod ,name ,@qualifier ,lambda-list
  446.        ,@body)))))
  447.   
  448.  
  449. (defmacro with-event (slots &body body)
  450.   "Used within an action method to access event slots."
  451.   
  452.   `(locally
  453.      (declare (special $event$))
  454.      
  455.      (unless (boundp '$event$)
  456.        (error "WITH-EVENT used outside the dynamic extent of PROCESS-NEXT-EVENT."))
  457.      
  458.      (with-slots ,slots (the event $event$) ,@body)))
  459.  
  460. (defmacro call-action (action &rest args)
  461.   "Used within DEFACTION to call another action. THIS MACRO IS NOW OBSOLETE. Replace
  462. with a direct reference to the ACTION function."
  463.   (declare (special $contact$))
  464.   (unless (boundp '$contact$)
  465.     (error "CALL-ACTION used outside DEFACTION."))
  466.   `(,action ,$contact$ ,@args))
  467.  
  468.  
  469. (proclaim '(inline call-action-internal))
  470. (defun call-action-internal (contact action)
  471.   (if (consp action)
  472.       (apply (car action) contact (cdr action))
  473.       (funcall action contact)))
  474.  
  475.  
  476. (defun add-before-action (display class action-name &rest args)
  477.   "Call the action named ACTION-NAME with ARGUMENTS before every event
  478.    on DISPLAY directed to a contact whose class is the same as
  479.    or superclass of the action class."
  480.   (let ((entry (list* class action-name (copy-list args))))
  481.     (setf (before-actions display)
  482.       (cons entry
  483.         (delete entry (before-actions display)
  484.             :count 1
  485.             :test #'equal))))
  486.   action-name)
  487.  
  488. (defun delete-before-action (display class action-name)
  489.   "Remove a before event-handler from display"
  490.   (setf (before-actions display)
  491.     (delete (cons class action-name)
  492.         (before-actions display)
  493.         :count 1
  494.         :test #'equal))
  495.   action-name)
  496.  
  497.  
  498. ;;;-----------------------------------------------------------------------------
  499. ;;; BUILT-IN ACTIONS
  500.  
  501.  
  502. (defmethod inside-contact-p ((contact contact) x y)
  503.   "Returns T when X/Y (in contact coordinates) is inside CONTACT"
  504.   (with-slots ((contact-width width) (contact-height height)) (the contact contact)
  505.     (and (<= 0 x)
  506.          (< x contact-width)
  507.      (<= 0 y)
  508.          (< y contact-height))))
  509.  
  510. (defmethod perform-callback ((contact basic-contact) name &rest args)  
  511.   ;; WARNING: duplicates apply-callback code, instead of (eval (apply-callback...))
  512.   (let ((functions (callback-p contact name)))
  513.     (when functions
  514.       (let ((args (copy-list args))        ;Cons Alert!!
  515.         (*contact* contact))
  516.     (catch :abort-callback
  517.       (do* ((functions functions         (rest functions))
  518.         (function  (first functions) (first functions)))
  519.            
  520.            ((null (rest functions))
  521.         ;; Return value(s) of last callback function
  522.         (apply (first function) (nconc args (rest function))))
  523.  
  524.         (setf args (nconc args (rest function)))
  525.         (apply (first function) args)
  526.         (setf args (nbutlast args (length (rest function))))))))))
  527.  
  528. (defmethod apply-action ((contact basic-contact) function &rest args)
  529.   (declare (special *contact*))
  530.   (let ((*contact* contact))
  531.     (apply function args)))
  532.  
  533. (defmethod eval-action ((contact basic-contact)  &rest forms)
  534.   (declare (special *contact*))
  535.   (let ((*contact* contact))
  536.     (dolist (form forms)
  537.       (eval form))))
  538.  
  539. (defmethod trace-action ((event-contact basic-contact)  &rest exceptions)
  540.   (let (value result
  541.     (name (contact-name event-contact)))    
  542.     (with-event ((event-key key))
  543.       (unless (member event-key exceptions :test #'eq)
  544.     (format *trace-output* "~%~s on ~a:"
  545.         event-key name)
  546.     (dolist (slot-name '(above-sibling atom border-width character child code colormap configure-p
  547.                  count drawable event-window focus-p format height hint-p installed-p keymap
  548.                  keysym kind major minor mode name new-p override-redirect-p parent place
  549.                  plist property requestor selection send-event-p state target type width
  550.                  window x y))
  551.       (when (and (setf value (slot-value (the event $event$) slot-name))
  552.              (not (eq value event-contact)))
  553.         (when (typep value 'contact) (setf value (contact-name value)))
  554.         (setf result (nconc result (list slot-name value)))))
  555.     (format *trace-output* "~{~<~%~20@t~1:; ~s ~s~>~^ ~}." result)))))
  556.  
  557. (defmethod describe-action ((event-contact basic-contact) &rest exceptions)
  558.   (with-event ((event-key key))
  559.     (unless (member event-key exceptions :test #'eq)
  560.       (format *trace-output* "~%~s on ~a:"
  561.           event-key (contact-name event-contact))
  562.       ;; Loop over slots in alphabetical order
  563.       (dolist (slot-name '(above-sibling atom border-width character child code colormap configure-p
  564.                count drawable event-window focus-p format height hint-p installed-p keymap keysym
  565.                kind major minor mode name new-p override-redirect-p parent place plist
  566.                property requestor selection send-event-p state target type width window x y))
  567.     (let ((value (slot-value (the event $event$) slot-name)))
  568.       (when value
  569.         (when (typep value 'contact) (setf value (contact-name value)))
  570.         (format *trace-output* "~%~5t~20s~20s" slot-name value))))
  571.       (terpri *trace-output*))))
  572.  
  573. (defmethod ignore-action ((contact basic-contact))
  574.   ;; Beep on *remap-events* else ignore
  575.   (with-event (key display)
  576.     (when (member key *remap-events* :test #'eq)
  577.       (bell display))))
  578.  
  579. (defmethod throw-action ((contact basic-contact) tag &optional value)
  580.   (throw tag value))
  581.  
  582.  
  583. ;;-----------------------------------------------------------------------------
  584. ;; EVENT-TRANSLATIONS
  585.  
  586. ;;; Macros For defining event handlers at compile-time:
  587.  
  588. (defmacro defevent (class event-spec &rest actions)
  589.   "Add an event binding to the EVENT-TRANSLATIONS property of CLASS,
  590.    where it can be shared by all instances of CLASS."
  591.   (let ((event-parse (parse-event-spec (list* event-spec actions))))
  592.     `(progn
  593.        ;; Generate compiler warnings for missing actions
  594.        #+ti ,@(mapcar #'(lambda (action)
  595.               (when (consp action) (setq action (car action)))
  596.               `(eval-when (compile)
  597.                  (compiler:function-referenced
  598.                    ',action ',(intern (format nil "~s Event ~s" class event-spec)))))
  599.               (cdr event-parse))
  600.        (set-event-bindings ',class ',(car event-parse)
  601.                ,@(mapcar #'(lambda (action) `(quote ,action)) (cdr event-parse))))))
  602.  
  603. (defun set-event-bindings (class event-spec &rest actions)
  604.   ;; Internal function used by DEFEVENT
  605.   (setf (get class 'event-translations)
  606.     (cons (cons event-spec (copy-list actions))
  607.           (delete event-spec
  608.               (get class 'event-translations)
  609.               :key #'car :test #'equal :count 1))))
  610.  
  611. (defmacro undefevent (class event-spec &rest actions)
  612.   "Remove an event binding from the EVENT-TRANSLATIONS property of CLASS."
  613.   (declare (ignore actions))
  614.   (let ((event-spec (parse-event-spec (list event-spec))))
  615.     `(delete-event-bindings ',class ',(car event-spec))))
  616.  
  617. (defun delete-event-bindings (class event-spec)
  618.   ;; Internal function used by UNDEFEVENT
  619.   (setf (get class 'event-translations)
  620.     (delete event-spec
  621.         (get class 'event-translations)
  622.         :key #'car :count 1 :test #'equal)))
  623.  
  624. ;;; Functions for defining event handlers at run-time:
  625.  
  626. (defun event-actions (contact event-spec)
  627.   "Return the list of actions for event-spec."
  628.   (declare (values action-list)) 
  629.  
  630.   ;; Check instance translations
  631.   (let ((event-binding (car (parse-event-spec (list event-spec)))))
  632.  
  633.     (cdr
  634.       (or
  635.     ;; Instance translation?
  636.     (assoc event-binding
  637.            (slot-value (the contact contact) 'event-translations)
  638.            :test #'equal)
  639.  
  640.     ;; Class translation?
  641.     (assoc event-binding
  642.            (get (class-name-of contact) 'event-translations)
  643.            :test #'equal)
  644.  
  645.     ;; Superclass class translation?
  646.     (dolist (class (class-all-superclasses (class-name-of contact)))
  647.       (let ((actions (assoc event-binding
  648.                 (get class 'event-translations)
  649.                 :test #'equal)))
  650.         (when actions
  651.           (return actions))))))))
  652.  
  653.  
  654. (defun add-event (contact event-spec &rest actions)
  655.   "Add EVENT-SPEC and ACTIONS to the event-translations for CONTACT."
  656.   (let ((event-binding  (parse-event-spec (list* event-spec (copy-list actions)))))
  657.     (with-slots (event-mask event-translations) (the contact contact)
  658.       (let ((previous (assoc (car event-binding) event-translations :test #'equal)))
  659.     (if previous
  660.         (setf (cdr previous) (cdr event-binding))
  661.       (push event-binding event-translations)))
  662.       (when (realized-p contact)
  663.     (let ((new-mask (update-event-mask event-binding event-mask)))
  664.       (unless (= new-mask event-mask) ;; When modified
  665.         (setf event-mask new-mask)
  666.         (setf (window-event-mask contact) event-mask))))))
  667.   (values))
  668.  
  669. (defun delete-event (contact event-spec)
  670.   "Remove EVENT-SPEC from the event-translations for CONTACT."
  671.   (let ((event-binding (parse-event-spec (list event-spec))))
  672.     (with-slots (event-mask event-translations) (the contact contact) 
  673.       ;; Compute event mask without current event translations    
  674.       (setf event-translations
  675.         (delete (car event-binding) event-translations
  676.             :key #'car :count 1
  677.             :test #'equal))
  678.       (when (realized-p contact)    
  679.     ;; Update the contact event mask
  680.     (let ((new-mask (compute-contact-event-mask contact))
  681.           (old-bit (update-event-mask event-binding 0)))
  682.       (when (zerop (logand new-mask old-bit)) ;; When modified
  683.         ;; Only modify the event-mask bit for the event being deleted
  684.         (setf new-mask (logandc2 event-mask old-bit)
  685.           event-mask new-mask
  686.           (window-event-mask contact) new-mask))))))
  687.   (values))
  688.  
  689.  
  690. ;;;-----------------------------------------------------------------------------
  691. ;;; EVENT-PARSING
  692.  
  693. ;; In X, there are event-NAMEs, which are used to specify which events are desired,
  694. ;; and event-KEYs, which are the names of specific events.  This ALIST maps
  695. ;; event-KEYs to event-MASK's.  This is used for automagicly creating the
  696. ;; event-name mask for window creation from the list of event-keys a contact is 
  697. ;; interested in.  If a third alist element is present, its a function to call
  698. ;; to compute the event-mask from the match parameters.
  699.  
  700. (defparameter *event-mask-alist*
  701.           '((:key-press #.(make-event-mask :key-press))
  702.         (:key-release #.(make-event-mask :key-release))
  703.         (:button-press #.(make-event-mask :button-press) button-press-mask)
  704.         (:button-release #.(make-event-mask :button-release) button-release-mask)
  705.         (:motion-notify  #.(make-event-mask :pointer-motion) motion-event-mask)
  706.         (:enter-notify #.(make-event-mask :enter-window))
  707.         (:leave-notify #.(make-event-mask :leave-window))
  708.         (:focus-in #.(make-event-mask :focus-change))
  709.         (:focus-out #.(make-event-mask :focus-change))
  710.         (:keymap-notify #.(make-event-mask :keymap-state))
  711.         (:exposure #.(make-event-mask :exposure))
  712.         (:graphics-exposure)
  713.         (:no-exposure)
  714.         (:visibility-notify #.(make-event-mask :visibility-change))
  715.         (:create-notify)        ; substructure-notify on parent
  716.         (:destroy-notify #.(make-event-mask :structure-notify))    ; or substructure-notify on parent
  717.         (:unmap-notify #.(make-event-mask :structure-notify))    ; or substructure-notify on parent
  718.         (:map-notify #.(make-event-mask :structure-notify))    ; or substructure-notify on parent
  719.         (:map-request)            ; substructure-notify on parent
  720.         (:reparent-notify #.(make-event-mask :structure-notify))    ; or substructure-notify on parent
  721.         (:configure-notify #.(make-event-mask :structure-notify))    ; or substructure-notify on parent
  722.         (:gravity-notify #.(make-event-mask :structure-notify))    ; or substructure-notify on parent
  723.         (:resize-request #.(make-event-mask :resize-redirect))
  724.         (:configure-request)        ; substructure-notify on parent
  725.         (:circulate-notify #.(make-event-mask :structure-notify))    ; or substructure-notify on parent
  726.         (:circulate-request)        ; substructure-notify on parent
  727.         (:property-notify #.(make-event-mask :property-change))
  728.         (:selection-clear)
  729.         (:selection-request)
  730.         (:selection-notify)
  731.         (:colormap-notify #.(make-event-mask :colormap-change))
  732.         (:client-message)
  733.         (:mapping-notify)
  734.         (:timer)
  735.         ))
  736.  
  737.  
  738. (defmacro check-function (event-key)
  739.   "Return the check function for parsing the EVENT-KEY."
  740.   `(get ,event-key 'check))
  741.  
  742.  
  743. (defun parse-event-spec (event-translation)
  744.   "Do error checking and canonicalization of an event translation."
  745.   (declare (values event-translations window-event-mask))
  746.   (cons (let ((event-spec (first event-translation)))
  747.       (typecase event-spec
  748.         (list
  749.          (let* ((key (car event-spec))
  750.             (real-key key)
  751.             (checker (check-function (car event-spec)))
  752.             (args nil))
  753.            (unless checker
  754.          (error "~s is not a known event keyword." (car event-spec) ))
  755.            (multiple-value-setq (args real-key)
  756.          (apply checker event-spec))
  757.            (unless real-key (setq real-key key))
  758.            (cons real-key args)))
  759.         
  760.         (character
  761.          (cons :key-press (key-check :key-press event-spec)))
  762.         
  763.         (otherwise
  764.          (unless (assoc event-spec *event-mask-alist* :test #'eq)
  765.            (error "~s is not a known event keyword." event-spec))
  766.          event-spec)))
  767.     
  768.     (cdr event-translation)))
  769.  
  770. (defun update-event-mask (event-translation event-mask)
  771.   "Return the LOGIOR of EVENT-MASK with the event mask determined by EVENT-TRANSLATION."
  772.   (let* ((event-spec (car event-translation))
  773.      (event-key  (if (consp event-spec) (car event-spec) event-spec))
  774.      (mask       (cdr (assoc event-key *event-mask-alist* :test #'eq))))
  775.     (cond ((null mask)       event-mask)
  776.       ((atom event-spec) (logior event-mask (car mask)))
  777.       ((cdr mask)        (logior event-mask (apply (cadr mask) (cddr event-spec))))
  778.       (t                 (logior event-mask (car mask))))))
  779.  
  780. (defun compute-contact-event-mask (contact)
  781.   "Compute an event-mask from the event translations (class and instance) for CONTACT."
  782.   (declare (values mask32))
  783.   (let ((mask  0)
  784.     (class (class-name-of contact)))
  785.     ;; Instance translations
  786.     (dolist (event (slot-value (the contact contact) 'event-translations))
  787.       (setq mask (update-event-mask event mask)))
  788.     ;; Class translations
  789.     (dolist (event (get class 'event-translations))
  790.       (setq mask (update-event-mask event mask)))
  791.     ;; Superclass translations
  792.     (dolist (class (class-all-superclasses class))
  793.       (dolist (event (get class 'event-translations))
  794.     (setq mask (update-event-mask event mask))))
  795.     mask))
  796.  
  797. ;;;-----------------------------------------------------------------------------
  798. ;;; CHECK/MATCH functions
  799.  
  800.  
  801. (defun encode-button-number (button)
  802.   (or (position button
  803.         #(:any :button-1 :button-2 :button-3 :button-4 :button-5))
  804.       (xlib::x-type-error
  805.     button 'button
  806.     "One of :Any :button-1 :button-2 :button-3 :button-4 :button-5")))
  807.  
  808. ;; Alist associating modifier keys with modifier keysyms
  809. (defvar *meta-modifier-alist*
  810.     '((:meta  #.(keysym :left-meta) #.(keysym :right-meta))
  811.       (:super #.(keysym :left-super) #.(keysym :right-super))
  812.       (:hyper #.(keysym :left-hyper) #.(keysym :right-hyper))))
  813.  
  814. (defconstant meta-shift 16.) ;; Where to shift meta-modifier keystates
  815. (defconstant mod-1-shift (position :mod-1 xlib::*state-mask-vector*))
  816. (defconstant button-0-shift (1- (position :button-1 xlib::*state-mask-vector*)))
  817.  
  818. (defun get-display-modifier-translate (display &optional update-p)
  819.   ;; Returns a table that translates meta-modifier bits
  820.   ;; into mod1/mod2/mod3/mod4/mod5 modifier state bits.
  821.   (declare (type display display)
  822.        (type boolean update-p))
  823.   (or (and (not update-p) (display-modifier-translate display))
  824.       (let* ((mapping (xlib::get-display-modifier-mapping display))
  825.          (mod-length (length *meta-modifier-alist*))
  826.          (translate-length (ash 1 mod-length))
  827.          (display-translate (display-modifier-translate display))
  828.          (translate (or (and (>= (length display-translate) translate-length)
  829.                  display-translate)
  830.                 (make-array translate-length)))
  831.          (mod-vector (make-array mod-length)))
  832.     (xlib::declare-array simple-vector translate mod-vector)
  833.     (do* ((modifiers *meta-modifier-alist* (cdr modifiers))
  834.           (i 0 (1+ i))
  835.           (temp))
  836.          ((endp modifiers))
  837.       (setf (aref mod-vector i)
  838.         (dolist (modifier (cdar modifiers) 0)
  839.           (when (setq temp (assoc modifier mapping :test #'eq))
  840.             (return (cdr temp))))))
  841.     (dotimes (i translate-length)
  842.       (let ((mask 0))
  843.         (dotimes (j mod-length)
  844.           (when (logbitp j i)
  845.         (setq mask (logior mask (aref mod-vector j)))))
  846.         (setf (aref translate i) mask)))
  847.     (setf (display-modifier-translate display) translate))))
  848.  
  849. (proclaim '(inline translate-meta-modifiers))
  850. (defun translate-meta-modifiers (state translate)
  851.   ;; Translate the meta/super/hyper modifiers in state to mod-1/mod-2/mod3/mod4/mod5 modifiers.
  852.   ;; TRANSLATE is the result from GET-DISPLAY-MODIFIER-TRANSLATE
  853.   (logior (ldb (byte meta-shift 0) state)
  854.       (aref translate (ash state (- meta-shift)))))
  855.  
  856. (defun encode-clue-modifier-mask (modifiers)
  857.   ;; Make a state-mask from modifiers
  858.   (declare (type (or mask16 state-mask-key (member :meta :super :hyper) list) modifiers)
  859.        (values mask16))
  860.   (typecase modifiers
  861.     (fixnum (ldb (byte meta-shift 0) modifiers))
  862.     (cons (let ((mask 0))
  863.         (dolist (modifier modifiers)
  864.           (logior mask (encode-clue-modifier-mask modifier)))
  865.         mask))
  866.     (otherwise
  867.      (let ((temp (position modifiers (the list *meta-modifier-alist*) :key #'car :test #'eq)))
  868.        (if temp
  869.        (ash 1 (+ temp meta-shift))
  870.      (make-state-mask modifiers))))))
  871.  
  872. (proclaim '(inline event-spec-match))
  873. (defun event-spec-match (display state select event-state)
  874.   (let ((translate (get-display-modifier-translate display)))
  875.     (setq state (translate-meta-modifiers state translate)
  876.       select (translate-meta-modifiers select translate)))
  877.                         ; The modifiers common to select and state must be DOWN and
  878.                         ; The modifiers in select but not state must be UP
  879.   (and (= (logand state select) (logand event-state select))
  880.                         ; When there are modifiers in state that aren't in select
  881.        (or (zerop (logandc2 state select))
  882.                         ; At least one of them must be DOWN
  883.        (plusp (logand event-state (logandc2 state select)))))
  884.                         ; Modifiers that aren't in state or select are ignored  
  885.   )
  886.  
  887. #| ;; event-spec-match implements the following relationships:
  888.  
  889.   .-------------------------------.
  890.   | event-state  4 4 4 4 4 4 4 4 4|
  891.   |4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4|
  892.   |4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4|
  893.   |4 4 .-------------------. 4 4 4|
  894.   |4 4 |  Select 1 1 1 1 1 | 4 4 4|
  895.   |4 4 | 1 1 1 1 1 1 1 1 1 | 4 4 4|
  896.   |4 4 | 1 .-----------. 1 | 4 4 4| This would look better in color
  897.   |4 4 | 1 | 2 2 2 2 2 | 1 | 4 4 4|
  898.   |4 4 | 1 | 2 2 2 2 2 | 1 | 4 4 4|
  899.   |4 4 | 1 | 2 2 2 2 2 | 1 | 4 4 4|
  900.   |4 4 `---+-----------+---' 4 4 4|
  901.   |4 4 4 4 | 3 3 3 3 3 | 4 4 4 4 4|
  902.   |4 4 4 4 | 3 3 3 3 3 | 4 4 4 4 4|
  903.   |4 4 4 4 | State 3 3 | 4 4 4 4 4|
  904.   |4 4 4 4 `-----------' 4 4 4 4 4|
  905.   |4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4|
  906.   |4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4|
  907.   `-------------------------------'
  908.  
  909.  1. Modifiers in select but not state        ; Must be UP in the event
  910.  2. Modifiers both in state and select        ; Must be DOWN in the event
  911.  3. Modifiers in state but not select        ; If any, at least one must be down
  912.  4. Modifiers in neither select or state    ; are ignored
  913.  
  914. |#
  915.  
  916. (defun key-check (event-key &optional char state select)
  917.   ;; Returns the canonical form of the key (i.e. one that may speed up
  918.   ;; the matching operation)
  919.   (when (not (typep char '(or card16 character (member :any))))
  920.     (error "parameter in ~s must be a CHARACTER, CARD16 or :ANY"
  921.        (list event-key char state select)))
  922.   (let* ((modifiers
  923.        (cond ((null state) (setq select 0)) ;; Default is :none
  924.          ((typep state 'fixnum) state)  ;; mask16
  925.          ((eq state :none) 0)
  926.          ((eq state :any) (setq select 0))
  927.          ((consp state)
  928.           (encode-clue-modifier-mask state))
  929.          (t (encode-clue-modifier-mask state))))
  930.      (mask 
  931.        (cond ((null select) #xffff)       ;; Default is all
  932.          ((typep select 'fixnum) select)  ;; mask16
  933.          ((eq select :all) (setq select #xffff))
  934.          ((eq select :same) modifiers)
  935.          ((consp select) (encode-clue-modifier-mask select))
  936.          (t (encode-clue-modifier-mask select)))))
  937.   (list 'key-match char modifiers mask)))
  938.  
  939. (defun key-match (event spec-code spec-state spec-select)
  940.   ;; Returns T if EVENT-SPEC matches EVENT
  941.   (with-slots (display character state keysym) (the event event)
  942.     (and (event-spec-match display spec-state spec-select state)
  943.      (cond
  944.        ((characterp spec-code) (eql spec-code character))
  945.        ((eq spec-code :any)    t)
  946.        (t                      (eql spec-code keysym))))))
  947.  
  948. (defun button-check (event-key &optional code state select)
  949.   (let* ((options nil)
  950.      (button (encode-button-number (or code :any)))
  951.      (modifiers
  952.        (cond ((null state) (setq select 0)) ;; Default is :none
  953.          ((typep state 'fixnum) state)  ;; mask16
  954.          ((eq state :none) 0)
  955.          ((eq state :any) (setq select 0))
  956.          ((eq state :test)
  957.           (push :test options)
  958.           (setq select 0))
  959.          ((eq state :single-click)
  960.           (push :single-click options)
  961.           (setq select 0))
  962.          ((eq state :double-click)
  963.           (push :double-click options)
  964.           (setq select 0))
  965.          ((consp state)
  966.           (cond ((member :single-click state)
  967.              (push :single-click options)
  968.              (unless (setq state (remove :single-click state))
  969.                (setq select 0)))
  970.             ((member :double-click state)
  971.              (push :double-click options)
  972.              (unless (setq state (remove :double-click state))
  973.                (setq select 0))))            
  974.           (encode-clue-modifier-mask state))
  975.          (t (encode-clue-modifier-mask state))))
  976.      (mask
  977.        (cond ((null select) modifiers)       ;; Default is same
  978.          ((typep select 'fixnum) select)  ;; mask16
  979.          ((eq select :same) modifiers)
  980.          ((eq select :all) (setq select #xffff))
  981.          ((consp select) (encode-clue-modifier-mask select))
  982.          (t (encode-clue-modifier-mask select))))
  983.      (predicate (if (eq event-key :button-press) 'button-press-match 'button-release-match)))
  984.     (list* predicate button modifiers mask options)))
  985.  
  986. (defun button-press-mask (button state select &optional option)
  987.   (declare (ignore button state select))
  988.   (if option
  989.       #.(make-event-mask :button-press :button-release)
  990.       #.(make-event-mask :button-press)))
  991.  
  992. (defun button-release-mask (button state select &optional option)
  993.   (declare (ignore button state select))
  994.   (if option
  995.       #.(make-event-mask :button-press :button-release)
  996.       #.(make-event-mask :button-release)))
  997.  
  998. (defun button-press-match (event button state select &optional option)
  999.   (with-slots ((event-code code)
  1000.            (event-state state)
  1001.            display key plist time x y)
  1002.           (the event event)
  1003.     (let* ((code event-code)
  1004.        (mask (ash 1 (+ code button-0-shift))))
  1005.       (and
  1006.     (or (zerop button)            ; Zero button means "any" button
  1007.         (=  button code))
  1008.     (event-spec-match display state select
  1009.               (logandc2 event-state mask))    ; Clear state bit for current button
  1010.     (case option
  1011.       (:single-click
  1012.        (= (click-lookahead display 1 2 time (logior event-state mask) x y) 2))
  1013.       (:double-click
  1014.        (= (click-lookahead display 1 4 time (logior event-state mask) x y) 4))
  1015.       (otherwise t))))))
  1016.  
  1017. (defun button-release-match (event button state select &optional option)
  1018.   (with-slots ((event-code code)
  1019.            (event-state state)
  1020.            key display plist time x y)
  1021.           (the event event)
  1022.     (let* ((code event-code)
  1023.        (mask (ash 1 (+ code button-0-shift))))
  1024.       (and
  1025.     (or (zerop button)            ; Zero button means "any" button
  1026.         (=  button code))
  1027.     (event-spec-match display state select (logandc2 event-state mask))    ; Clear state bit for current button
  1028.     (case option
  1029.       (:single-click
  1030.        (= (click-lookahead display 2 2 time event-state x y) 2))
  1031.       (:double-click
  1032.        (= (click-lookahead display 2 4 time event-state x y) 4))
  1033.       (otherwise t))))))
  1034.  
  1035. (defconstant all-button-mask (make-state-mask :button-1 :button-2 :button-3 :button-4 :button-5))
  1036.  
  1037. (defun motion-check (event-key &optional state select)
  1038.   (declare (ignore event-key))
  1039.   (let* ((modifiers
  1040.        (cond ((null state) (setq select 0)) ;; Default is :none
  1041.          ((typep state 'fixnum) state)  ;; mask16
  1042.          ((eq state :none) 0)
  1043.          ((eq state :any) (setq select 0) all-button-mask)
  1044.          ((consp state)
  1045.           (encode-clue-modifier-mask state))
  1046.          (t (encode-clue-modifier-mask state))))
  1047.      (mask 
  1048.        (cond ((null select) #xffff)       ;; Default is all
  1049.          ((typep select 'fixnum) select)  ;; mask16
  1050.          ((eq select :all) (setq select #xffff))
  1051.          ((eq select :same) modifiers)
  1052.          ((consp select) (encode-clue-modifier-mask select))
  1053.          (t (encode-clue-modifier-mask select)))))
  1054.     (list 'motion-match modifiers mask)))
  1055.  
  1056. (defun motion-match (event state select)
  1057.   (with-slots (display) (the event event)
  1058.     (or (eq state :any)
  1059.     (event-spec-match display state select (slot-value (the event event) 'state)))))
  1060.  
  1061. (defun motion-event-mask (state select)
  1062.   (if (= all-button-mask (logand (logior state select) all-button-mask))
  1063.       #.(make-event-mask :button-motion)
  1064.       (let ((mask (logand state select all-button-mask)))
  1065.     (when (zerop mask)
  1066.       (setq mask #.(make-event-mask :pointer-motion)))
  1067.     mask)))
  1068.  
  1069. (eval-when (compile) ;; motion-event-mask makes the following assumption:
  1070.   (assert (and (= (make-event-mask :button-1-motion) (make-state-mask :button-1))
  1071.            (= (make-event-mask :button-2-motion) (make-state-mask :button-2))
  1072.            (= (make-event-mask :button-3-motion) (make-state-mask :button-3))
  1073.            (= (make-event-mask :button-4-motion) (make-state-mask :button-4))
  1074.            (= (make-event-mask :button-5-motion) (make-state-mask :button-5)))
  1075.       () "Button event-mask is shifted relative to button state-mask"))
  1076.  
  1077. (defun enter-leave-check (event-key &rest kinds)
  1078.   (dolist (kind kinds)
  1079.     (unless (member kind '(:ancestor :virtual :inferior :nonlinear :nonlinear-virtual))
  1080.       (error "~s isn't an enter/leave kind for ~s" kind (cons event-key kinds))))
  1081.   (list 'enter-leave-match kinds))
  1082.  
  1083. (defun enter-leave-match (event kinds)
  1084.   (member (slot-value (the event event) 'kind) kinds :test #'eq))
  1085.  
  1086. (setf (check-function :key-press) 'key-check)
  1087. (setf (check-function :key-release) 'key-check)
  1088. (setf (check-function :button-press) 'button-check)
  1089. (setf (check-function :button-release) 'button-check)
  1090. (setf (check-function :motion-notify) 'motion-check)
  1091. (setf (check-function :enter-notify) 'enter-leave-check)
  1092. (setf (check-function :leave-notify) 'enter-leave-check)
  1093.  
  1094. (defun key-up-check (event-key &rest parms)
  1095.   (declare (ignore event-key))
  1096.   ;; Convert (:up ...) to (:key-press ...)
  1097.   (values (apply #'key-check :key-release parms)
  1098.        :key-release))
  1099.  
  1100. (setf (check-function :up) #'key-up-check)
  1101.  
  1102. (defun client-message-check (event-key type &rest accessors)
  1103.   (declare (ignore event-key))
  1104.   (assert (typep type 'xatom) () "~s must be an X atom." type)
  1105.   (do* ((accessors accessors          (cddr accessors))
  1106.     (function  (first accessors)  (first accessors))
  1107.     (rest      (rest accessors)   (rest accessors)))
  1108.        ((null accessors))    
  1109.     (assert rest () "No value given for ~s accessor." function))
  1110.   (values (list* 'client-message-match
  1111.          (intern (string type) 'keyword)
  1112.          accessors)
  1113.       :client-message))
  1114.  
  1115. (defun client-message-match (event type &rest accessors)
  1116.   (with-slots ((event-type type) (event-data data) (event-display display)) event
  1117.     ;; Bind display for use in accessor functions
  1118.     (let ((*event-display* event-display))
  1119.       (declare (special *event-display*))
  1120.       (and (eq type event-type)
  1121.        (do* ((accessors accessors          (cddr accessors))
  1122.          (function  (first accessors)  (first accessors))
  1123.          (value     (second accessors) (second accessors)))
  1124.         ((null accessors) t)
  1125.          (unless (equal value (funcall function event-data))
  1126.            (return nil)))))))
  1127.  
  1128. (setf (check-function :client-message) #'client-message-check)
  1129.  
  1130.  
  1131. (defun wm-protocol-check (event-key &rest accessors)
  1132.   (apply 'client-message-check
  1133.      :client-message :wm_protocols
  1134.      'wm-message-protocol-atom event-key
  1135.      accessors))
  1136.  
  1137. (setf (check-function :wm_take_focus)    #'wm-protocol-check)
  1138. (setf (check-function :wm_save_yourself) #'wm-protocol-check)
  1139. (setf (check-function :wm_delete_window) #'wm-protocol-check)
  1140.  
  1141.   
  1142. ;;;-----------------------------------------------------------------------------
  1143. ;;; DOUBLE-CLICK events
  1144.  
  1145. (defun click-lookahead (display count max first-time state first-x first-y)
  1146.   (declare (type card8 count)) ;; even when the button is UP, odd when DOWN
  1147.  
  1148.   (let* ((multipress-verify-p (display-multipress-verify-p display))
  1149.      (multipress-delay-limit (display-multipress-delay-limit display))
  1150.      (timeout (/  multipress-delay-limit 1000.0))
  1151.      (distance-limit 5))
  1152.     
  1153.     (flet ((get-result (count timeoutp)
  1154.                ;; If the result from GET-RESULT is NIL, all lookahead events
  1155.                ;; remain on the event queue, otherwise the events are removed,
  1156.                ;; and the result from GET-RESULT is returned.
  1157.                (if (or (evenp count)    ; Hold events only occur on timeout
  1158.                    timeoutp)
  1159.                count
  1160.                0)))
  1161.       (loop
  1162.     (let*
  1163.       ((timeout-p t)
  1164.        (result
  1165.          (block result
  1166.            ;; When succeeding, we want to "eat" the events.
  1167.            ;; When failing, we want to leave events on the event queue.
  1168.            ;; We're careful to return non-nil from event-case only on success.
  1169.            ;; On failure, we return-from result, which leaves events on the queue.
  1170.            ;; the timeout-p hair is to detect the difference between failure and timeout.
  1171.            (event-case (display :timeout timeout :force-output-p nil)
  1172.          ((motion-notify) (x y)        ; Fail when pointer moves more than a jiggle
  1173.           (setq timeout-p nil)
  1174.           (when (> (+ (abs (- x first-x)) (abs (- y first-y))) distance-limit)
  1175.             (return-from result (get-result count nil))))
  1176.          
  1177.          ((enter-notify leave-notify) ()    ; Fail when pointer moves to a new window
  1178.           (setq timeout-p nil)
  1179.           (return-from result (get-result count nil)))
  1180.          
  1181.          (button-press (time (state event-state) code)
  1182.                    (setq timeout-p nil)
  1183.                    (cond ((>= count max) (return-from result :count))
  1184.                      ((> time (+ first-time multipress-delay-limit))
  1185.                       (return-from result :timeout))
  1186.                      ((or (oddp count)
  1187.                       (not (= state (logior event-state (ash 1 (+ code button-0-shift))))))
  1188.                       (return-from result (get-result count nil)))
  1189.                      (t (let ((result (click-lookahead display (1+ count) max
  1190.                                        time state first-x first-y)))
  1191.                       (if (plusp result)
  1192.                           result
  1193.                           (if (plusp (setq result (get-result count nil)))
  1194.                           (return-from result result)
  1195.                           nil ;; else fall-through returning NIL
  1196.                           ))))))
  1197.          
  1198.          (button-release (time (state event-state))
  1199.                  (setq timeout-p nil)
  1200.                  (cond ((>= count max) (return-from result :count))
  1201.                        ((> time (+ first-time multipress-delay-limit))
  1202.                     (return-from result :timeout))
  1203.                        ((or (evenp count)
  1204.                         (not (= state event-state)))
  1205.                     (return-from result (get-result count nil)))
  1206.                        (t (let ((result (click-lookahead display (1+ count) max
  1207.                                      time state first-x first-y)))
  1208.                         (if (plusp result)
  1209.                         result
  1210.                         (if (plusp (setq result (get-result count nil)))
  1211.                             (return-from result result)
  1212.                             nil ;; else fall-through returning NIL
  1213.                             ))))))))))
  1214.       
  1215.       (if timeout-p
  1216.           ;; event-case timed out
  1217.           (if (or (zerop timeout)
  1218.               (not multipress-verify-p))
  1219.           
  1220.           (return (get-result count :local-timeout))
  1221.           
  1222.           (progn
  1223.             ;; Verify timeout with a server round-trip and event-queue recheck
  1224.             (display-finish-output display)
  1225.             (setq timeout 0)))
  1226.           
  1227.           ;; Else exit loop with result
  1228.           (return (case result
  1229.             (:timeout  (get-result (1- count) :timeout))
  1230.             (:count    0)
  1231.             (nil       0)
  1232.             (otherwise result)))))))))
  1233.  
  1234.  
  1235.  
  1236. ;;;-----------------------------------------------------------------------------
  1237. ;;; EVENT-PROCESSING
  1238.  
  1239. (defun process-all-events (display)
  1240.   "Process all pending events"
  1241.   (loop
  1242.     (xlib:display-finish-output display)
  1243.     (let ((n-events (xlib:event-listen display)))
  1244.       (if n-events
  1245.       (dotimes (i n-events)
  1246.         (process-next-event display))
  1247.     ;; Return when no events are queued after event-listen
  1248.     (return nil)))))
  1249.  
  1250.  
  1251. (defun process-next-event (display &optional timeout)
  1252.   "Process one event."
  1253.   (declare (type display display)        ; The display (from initialize-clue)
  1254.        (type (or null number) timeout)    ; optional timeout in seconds
  1255.        (values boolean))            ; Returns NIL only if timeout exceeded
  1256.  
  1257.   ;; Ensure consistent contact states
  1258.   (update-state display)
  1259.   (internal-process-next-event display timeout))
  1260.  
  1261. (defun internal-process-next-event (display &optional timeout)
  1262.   "Process one event."
  1263.   (declare (type display display)        ; The display (from initialize-clue)
  1264.        (type (or null number) timeout)    ; optional timeout in seconds
  1265.        (values boolean))            ; Returns NIL only if timeout exceeded
  1266.  
  1267.  
  1268.   (let*
  1269.     (;; Process any timers that have expired
  1270.      (interval-until-next-timer  (execute-timers display))
  1271.      
  1272.      ;; Compute true timeout
  1273.      (wait-for-timer-p           (when (or (null timeout)
  1274.                        (and interval-until-next-timer
  1275.                         (< interval-until-next-timer timeout)))                      
  1276.                    interval-until-next-timer))
  1277.      
  1278.      (event                      (allocate-event))
  1279.      (result                     nil))    
  1280.     
  1281.     (setf (slot-value (the event event) 'display) display)
  1282.     
  1283.     (macrolet ((set-event (&rest parameters)
  1284.          `(progn ,@(mapcar #'(lambda (parm)
  1285.                        `(setf (slot-value (the event event) ',parm) ,parm))
  1286.                    parameters)))
  1287.            (dispatch (contact)
  1288.           `(progn
  1289.              (dispatch-event event event-key send-event-p sequence ,contact)
  1290.              t)))
  1291.       ;; Wait for an event, copy info into the EVENT structure then call DISPATCH-EVENT
  1292.       (setf
  1293.     result
  1294.     (or
  1295.       (xlib:event-cond (display :timeout (or wait-for-timer-p timeout)
  1296.                     :force-output-p t
  1297.                     :discard-p t)
  1298.         ((:key-press :key-release :button-press :button-release)
  1299.          (code time root window child root-x root-y x y
  1300.            state same-screen-p event-key sequence send-event-p) t
  1301.          (set-event code time root window child root-x root-y x y
  1302.             state same-screen-p)
  1303.          (dispatch window))
  1304.         
  1305.         (:motion-notify
  1306.           (hint-p time root window child root-x root-y x y
  1307.               state same-screen-p event-key sequence send-event-p) t
  1308.           (set-event hint-p time root window child root-x root-y x y
  1309.              state same-screen-p)
  1310.           (dispatch window))
  1311.         
  1312.         ((:enter-notify :leave-notify)
  1313.          (kind time root window child root-x root-y x y
  1314.            state mode focus-p same-screen-p event-key sequence send-event-p) t
  1315.          (set-event kind time root window child root-x root-y x y
  1316.             state mode focus-p same-screen-p)
  1317.          (dispatch window))
  1318.         
  1319.         ((:focus-in :focus-out)
  1320.          (kind window mode event-key sequence send-event-p) t
  1321.          (set-event kind window mode)
  1322.          (dispatch window))
  1323.         
  1324.         (:exposure
  1325.           (window x y width height count event-key sequence send-event-p) t
  1326.           (set-event window x y width height count)
  1327.           (dispatch window))
  1328.         
  1329.         (:graphics-exposure
  1330.           (drawable x y width height count major minor event-key sequence send-event-p) t
  1331.           (set-event drawable x y width height count major minor)
  1332.           (dispatch drawable))
  1333.         
  1334.         (:no-exposure
  1335.           (drawable major minor event-key sequence send-event-p) t
  1336.           (set-event drawable major minor)
  1337.           (dispatch drawable))
  1338.         
  1339.         (:visibility-notify
  1340.           (window state event-key sequence send-event-p) t
  1341.           (set-event window state)
  1342.           (dispatch window))
  1343.         
  1344.         (:create-notify
  1345.           (parent window x y width height border-width
  1346.               override-redirect-p event-key sequence send-event-p) t
  1347.           (set-event parent window x y width height border-width
  1348.              override-redirect-p)
  1349.           (dispatch parent))
  1350.         
  1351.         (:destroy-notify
  1352.           (event-window window event-key sequence send-event-p) t
  1353.           (set-event event-window window)
  1354.           (dispatch event-window))
  1355.         
  1356.         (:unmap-notify
  1357.           (event-window window configure-p event-key sequence send-event-p) t
  1358.           (set-event event-window window configure-p)
  1359.           (dispatch event-window))
  1360.         
  1361.         (:map-notify
  1362.           (event-window window override-redirect-p event-key sequence send-event-p) t
  1363.           (set-event event-window window override-redirect-p)
  1364.           (dispatch event-window))
  1365.         
  1366.         (:map-request
  1367.           (parent window event-key sequence send-event-p) t
  1368.           (set-event parent window)
  1369.           (dispatch parent))
  1370.         
  1371.         (:reparent-notify
  1372.           (event-window window parent x y override-redirect-p event-key sequence send-event-p) t
  1373.           (set-event event-window window parent x y override-redirect-p)
  1374.           (dispatch event-window))
  1375.         
  1376.         (:configure-notify
  1377.           (event-window window above-sibling x y width height border-width
  1378.                 override-redirect-p event-key sequence send-event-p) t
  1379.           (set-event event-window window above-sibling x y width height
  1380.              border-width override-redirect-p)
  1381.           (dispatch event-window))
  1382.         
  1383.         (:configure-request
  1384.           (parent window above-sibling x y width height border-width event-key sequence send-event-p) t
  1385.           (set-event parent window above-sibling x y width height border-width)
  1386.           (dispatch parent))
  1387.         
  1388.         (:gravity-notify
  1389.           (event-window window x y event-key sequence send-event-p) t
  1390.           (set-event event-window window x y)
  1391.           (dispatch event-window))
  1392.         
  1393.         (:resize-request
  1394.           (window width height event-key sequence send-event-p) t
  1395.           (set-event window width height)
  1396.           (dispatch window))
  1397.         
  1398.         (:circulate-notify
  1399.           (event-window window parent place event-key sequence send-event-p) t
  1400.           (set-event event-window window parent place)
  1401.           (dispatch event-window))
  1402.         
  1403.         (:circulate-request
  1404.           (parent window place event-key sequence send-event-p) t
  1405.           (set-event parent window place)
  1406.           (dispatch parent))
  1407.         
  1408.         (:property-notify
  1409.           (window atom time state event-key sequence send-event-p) t
  1410.           (set-event window atom time state)
  1411.           (dispatch window))
  1412.         
  1413.         (:selection-clear
  1414.           (time window selection event-key sequence send-event-p) t
  1415.           (set-event time window selection)
  1416.           (dispatch window))
  1417.         
  1418.         (:selection-request
  1419.           (time window requestor selection target property event-key sequence send-event-p) t
  1420.           (set-event time window requestor selection target property)
  1421.           (dispatch window))
  1422.         
  1423.         (:selection-notify
  1424.           (time window selection target property event-key sequence send-event-p) t
  1425.           (set-event time window selection target property)
  1426.           (dispatch window))
  1427.         
  1428.         (:colormap-notify
  1429.           (window colormap new-p installed-p event-key sequence send-event-p) t
  1430.           (set-event window colormap new-p installed-p)
  1431.           (dispatch window))
  1432.         
  1433.         (:client-message
  1434.           (format window type data event-key sequence send-event-p) t
  1435.           (set-event format window type data)
  1436.           (dispatch window))
  1437.         
  1438.         (:keymap-notify            ; Special case
  1439.           (keymap event-key send-event-p) t
  1440.           (set-event keymap)        ; keymap-notify doesn't have an associated window.
  1441.           (let ((sequence 0))
  1442.         (dispatch (display-root display))))    ; Send keymap-notify events to the root.
  1443.         
  1444.         (:mapping-notify            ; Special case
  1445.           (request start count) t
  1446.           (mapping-notify display request start count)
  1447.           (when (eq request :modifier)    ; Update the modifier mapping translate table
  1448.         (get-display-modifier-translate display :update))
  1449.           t))
  1450.  
  1451.       ;; No event read -- return true (i.e. no timeout) if we now have a timer ready
  1452.       (when wait-for-timer-p t))))
  1453.     
  1454.     ;; We could add an unwind protect to ensure that the event is always
  1455.     ;; deallocated (process-next-event is sometimes thrown out of).
  1456.     ;; However, we judge that an unwind-protect all the time is more
  1457.     ;; expensive than garbage collecting an event structure some of the
  1458.     ;; time.
  1459.     (deallocate-event event)
  1460.     
  1461.     result))
  1462.  
  1463.  
  1464.  
  1465. (defun dispatch-event (event event-key send-event-p sequence contact)
  1466.   ;; Called from PROCESS-NEXT-EVENT to filter events and call event handlers.
  1467.   (declare (inline sensitive-p))
  1468.   (with-slots ((event_key key)
  1469.            (event-sequence sequence)
  1470.            (event-send-event-p send-event-p)
  1471.            (event-contact contact)) (the event event)
  1472.     (setf event_key event-key
  1473.       event-send-event-p send-event-p
  1474.       event-sequence sequence
  1475.       event-contact contact))
  1476.   ;;
  1477.   ;; Check for destroyed or invalid event-windows
  1478.   ;;
  1479.   (if (not (typep contact 'basic-contact))
  1480.       ;; Not a contact!!  Let the default root contact handle the event
  1481.       (handle-event (display-root (drawable-display contact)) event)
  1482.       
  1483.       (if (destroyed-p contact)
  1484.       
  1485.       ;; Destroyed-contact!
  1486.       (when (eq event-key :destroy-notify)
  1487.         (destroy-finish contact))
  1488.  
  1489.       ;; Bind event for reference within with-event forms
  1490.       (let (($event$ event))
  1491.         (declare (special $event$))
  1492.         
  1493.         ;;
  1494.         ;; Do key translation
  1495.         ;;
  1496.         (when (or (eq event-key :key-press)
  1497.               (eq event-key :key-release))
  1498.           (with-slots (keysym character display code state) (the event event)
  1499.         (let ((keysym-index (default-keysym-index display code state)))
  1500.           (setf keysym (keycode->keysym display code keysym-index)
  1501.             character (keycode->character display code state :keysym-index keysym-index)))))
  1502.         ;;
  1503.         ;; Call the before event handlers
  1504.         ;;
  1505.         (let ((actions (before-actions (contact-display contact))))
  1506.           (when actions
  1507.         (let ((class (class-name-of contact)))          
  1508.           (dolist (before-action actions)
  1509.             (when (subtypep class (car before-action))
  1510.               (call-action-internal contact (cdr before-action)))))))
  1511.         ;;
  1512.         ;; Handle insensitive contacts
  1513.         ;;
  1514.         (when (and (member event-key *sensitive-events* :test #'EQ)
  1515.                (not (sensitive-p contact)))
  1516.           (return-from dispatch-event nil))
  1517.         
  1518.         ;;
  1519.         ;; Handle modes 
  1520.         ;;
  1521.         (let ((modes (display-mode-stack (contact-display contact))))
  1522.           (when (and modes (not (contact-mode contact)))
  1523.         (when
  1524.           (or (member event-key *restrict-events* :test #'eq)
  1525.               (and (member event-key *remap-events* :test #'eq)
  1526.                (dolist (mode modes t) ;; Search for first :spring-loaded mode
  1527.                  (when (eq (second mode) :spring-loaded)
  1528.                    (format t "~%Remapping ~s from ~s to ~s" event-key contact (first mode)) ;; *** DEBUG ***
  1529.                    (setq contact (first mode)) ;; Remap contact
  1530.                    (return nil)))))
  1531.           ;; Call mode action on for first :exclusive or :spring-loaded mode
  1532.           (dolist (mode modes)
  1533.             (unless (eq (second mode) :non-exclusive)
  1534.               (call-action-internal (first mode) (cddr mode))
  1535.               ;; quit
  1536.               (return-from dispatch-event nil))))))
  1537.         
  1538.         ;; 
  1539.         ;; Handle event compression
  1540.         ;;
  1541.         (with-slots ((contact-compress-motion compress-motion)
  1542.              (contact-compress-exposures compress-exposures))
  1543.             (the contact contact)
  1544.           
  1545.           (case event-key
  1546.         (:exposure            ; Check for exposure compression
  1547.          (when (and (eq contact-compress-exposures :on)
  1548.                 (plusp (slot-value (the event event) 'count)))
  1549.            (return-from dispatch-event nil)))
  1550.         
  1551.         (:motion-notify            ; Check for motion compression
  1552.          (when (eq contact-compress-motion :on)
  1553.            (let ((count 0))
  1554.              
  1555.              ;; Count consecutive :motion-notify's currently in queue
  1556.              (event-case ((contact-display contact) :peek-p t :timeout 0)
  1557.                (:motion-notify (window)
  1558.                        (not (and (eq window contact) (incf count))))
  1559.                (otherwise ()   t))
  1560.              
  1561.              (when (plusp count) 
  1562.                ;; Remove all but last and quit immediately
  1563.                (do () ((zerop (decf count)))
  1564.              (event-case ((contact-display contact) :timeout 0)
  1565.                (otherwise ()   t)))
  1566.                (return-from dispatch-event nil)))))))
  1567.         ;;
  1568.         ;; Handle event translations
  1569.         ;;
  1570.         (handle-event contact event)))))
  1571.  
  1572. (defmethod handle-event ((contact basic-contact) (event event))
  1573.   "Do event/callback translation based on the event-translations slot."
  1574.   (declare (type contact contact)
  1575.        (type event event))
  1576.   ;;
  1577.   ;; Handle universal events
  1578.   ;;
  1579.   (when (eq :exposure (slot-value (the event event) 'key))
  1580.     (with-slots (x y width height) (the event event)
  1581.       (display contact x y width height)))
  1582.  
  1583. ;; The following "universal event" is obsolete -- use shells for top-level windows
  1584. ;    (:configure-notify
  1585. ;     ;; A contact's x/y/width/height/border-width get updated immediately when
  1586. ;     ;; changing geometry.  Top-level windows however, have their geometry
  1587. ;     ;; arbitrated by the window-manager.  It probably doesn't make sense for
  1588. ;     ;; a non-top-level contact to select structure-notify.  Because CLUE allows
  1589. ;     ;; any contact to be top-level, CLUE automatically selects structure-notify
  1590. ;     ;; for top-level contracts, and we set the size/position here.
  1591. ;     ;; If non-top-level contacts select structure-notify, we let them handle it
  1592. ;     ;; themselves.
  1593. ;     ;;
  1594. ;     ;; This is inadequate.  The geometry manager for the
  1595. ;     ;; root should be used instead, waiting for the configure-notify,
  1596. ;     ;; and returning an appropriate successs-p parameter.
  1597. ;     ;;
  1598. ;     (with-slots (x y width height border-width window) (the event event)
  1599. ;       (when (and (eq window contact) (top-level-p contact))
  1600. ;     (without-requests contact
  1601. ;       (move contact x y)
  1602. ;       (resize contact width height border-width)))))
  1603.     
  1604.   ;;
  1605.   ;; Translate event and perform contact actions
  1606.   ;;
  1607.   (dolist (action (translate-event contact event))
  1608.     (call-action-internal contact action))
  1609.   
  1610.   t)
  1611.  
  1612. (defun translate-event (contact event)
  1613.   "Returns the actions for the first event-translation matching EVENT"
  1614.   (declare (type contact contact)
  1615.        (type event event))
  1616.   (labels ((find-translation (event event-key translations)
  1617.          (dolist (event-binding translations)
  1618.            (let ((event-spec (car event-binding)))
  1619.          (when (if (atom event-spec)
  1620.                ;; Simple EQ test when event spec is an atom
  1621.                (eq event-key event-spec)
  1622.              ;; When event spec is a list, and
  1623.              ;; the car of the list is EQ to the event, and
  1624.              ;; the matcher function returns T
  1625.              (and (eq event-key (car event-spec))
  1626.                   (apply (cadr event-spec) event (cddr event-spec))))
  1627.            (return event-binding))))))
  1628.  
  1629.     (let ((key (slot-value (the event event) 'key))
  1630.       class)
  1631.       (cdr
  1632.     (or
  1633.       ;; Instance translations
  1634.       (find-translation event key (slot-value (the basic-contact contact) 'event-translations))
  1635.  
  1636.       ;; Immediate class translations
  1637.       (find-translation event key (get (setq class (class-name-of contact)) 'event-translations))
  1638.       
  1639.       ;; Superclass class translations 
  1640.       (dolist (class (class-all-superclasses class))
  1641.         (let ((translation (find-translation event key (get class 'event-translations))))
  1642.           (when translation (return translation)))))))))
  1643.  
  1644. (defmethod translate-key ((contact contact) event)
  1645.   ;; Find a translation for :key-press event EVENT which
  1646.   ;; was originally sent to CONTACT.
  1647.   (let* ((parent (contact-parent contact))
  1648.      (siblings (and parent (composite-children parent)))
  1649.      actions)
  1650.     (or ;; Check for handled by a sibling
  1651.       (dolist (sibling siblings)
  1652.     (unless (eq sibling contact)
  1653.       (when (setq actions (translate-event sibling event))
  1654.         (setf (slot-value (the event event) 'contact) sibling)
  1655.         (dolist (action actions t)
  1656.           (call-action-internal sibling action))
  1657.         (return t))))
  1658.       ;; If not handled by a sibling of contact, check the parent
  1659.       (when (and parent
  1660.          (setq actions (translate-key parent event)))
  1661.     (setf (slot-value (the event event) 'contact) parent)
  1662.     (dolist (action actions t)
  1663.       (call-action-internal parent action)))
  1664.       ;; Not handled by parent, recurse up to the parent
  1665.       (translate-key parent contact))))
  1666.  
  1667.  
  1668. ;;-----------------------------------------------------------------------------
  1669. ;; TIMERS
  1670.  
  1671. (defstruct timer
  1672.   name
  1673.   time
  1674.   interval
  1675.   contact
  1676.   data)
  1677.  
  1678. (defun add-timer (contact name interval &optional data)
  1679.   "Send a :timer event to CONTACT every INTERVAL seconds passing DATA
  1680.  The timer will be named NAME.  The event is passed DATA NAME CONTACT and DISPLAY"
  1681.   ;; Timers are automatically removed when CONTACT is destroyed
  1682.   (declare (type contact contact)
  1683.        (type number interval) ;; in seconds
  1684.        (values timer))
  1685.   (delete-timer contact name)
  1686.   (insert-timer (make-timer
  1687.           :name name
  1688.           :interval (* interval internal-time-units-per-second)
  1689.           :contact contact
  1690.           :data data))
  1691.   name)
  1692.  
  1693. ;; Internal function
  1694. (defun insert-timer (timer)
  1695.   ;; Insert timer into its timer-queue
  1696.   (let* ((display  (contact-display (timer-contact timer)))
  1697.      (queue    (timer-queue display))
  1698.      (interval (timer-interval timer))
  1699.      (time     (+ interval (get-internal-real-time))))
  1700.     
  1701.     (setf (timer-time timer) time)
  1702.     
  1703.     ;; Insert in order of execution (youngest first)
  1704.     (if (or (null queue) (< time (timer-time (first queue))))
  1705.     
  1706.     (push timer (timer-queue display))
  1707.     
  1708.     (loop
  1709.       (when (or (null (cdr queue))
  1710.             (< time (timer-time (cadr queue))))
  1711.         (return (setf (cdr queue) (cons timer (cdr queue)))))
  1712.       (pop queue)))
  1713.     
  1714.     timer))
  1715.  
  1716. (defun delete-timer (contact &optional timer-name)
  1717.   "Remove timer named TIMER-NAME from CONTACT
  1718.  If timer-name is NIL, remove ALL timers from CONTACT.
  1719.  Returns NIL when timer not found, else T."
  1720.   (let* ((display (contact-display contact))
  1721.      (timer-queue (timer-queue display))
  1722.      (deletedp nil))
  1723.     (dolist (timer timer-queue)
  1724.       (when (and (eq (timer-contact timer) contact)
  1725.          (or (null timer-name)
  1726.              (equal (timer-name timer) timer-name)))
  1727.     (setq deletedp t)
  1728.     (setf (timer-queue display)
  1729.           (delete timer timer-queue :test #'eq :count 1))
  1730.     (when timer-name
  1731.       (return t))))
  1732.     ;; Return T when timers deleted
  1733.     deletedp))
  1734.  
  1735.  
  1736. (defun execute-timers (display)
  1737.   "Execute all timers whose time has come, returning the time (in seconds)
  1738.  before the next timer executes for DISPLAY"
  1739.   (loop
  1740.     (let ((next-timer (car (timer-queue display))))
  1741.  
  1742.       (unless next-timer
  1743.     ;; No timers active
  1744.     (return nil))
  1745.  
  1746.       (let ((next-time  (timer-time next-timer)))
  1747.     (when (> next-time (get-internal-real-time))
  1748.       ;; Return time interval before next timer fires
  1749.       (return
  1750.         (/ (- next-time (get-internal-real-time))
  1751.            #.(float internal-time-units-per-second)))))
  1752.  
  1753.       ;; Reinsert timer for next firing
  1754.       (pop (timer-queue display)) ;; Warning: If an abort happens here, There's a short
  1755.       (insert-timer next-timer)   ;;          interval where a timer may be lost.
  1756.  
  1757.       ;; Dispatch a :timer event
  1758.       (let ((event (allocate-event)))
  1759.     (with-slots ((event-display display)
  1760.              name data) (the event event)
  1761.       (setf event-display display
  1762.         name (timer-name next-timer)
  1763.         data (timer-data next-timer)))
  1764.     (dispatch-event event :timer nil 0 (timer-contact next-timer))
  1765.     (deallocate-event event)))))
  1766.  
  1767.  
  1768. ;;;-----------------------------------------------------------------------------
  1769. ;;; Utility functions
  1770.  
  1771. (defun describe-event-translations (contact &optional (stream *standard-output*))
  1772.   "Print the event translations for CONTACT
  1773.    If contact is a contact class name, print the event translations
  1774.    for that contact class."
  1775.   (flet ((print-event (class event stream)
  1776.        (format stream "~%From ~20a ~s" class (car event))
  1777.        (dolist (action (cdr event))
  1778.          (write-char #\space stream)
  1779.          (prin1 action stream))))
  1780.     
  1781.     (let ((class        (if (symbolp contact)
  1782.                 contact
  1783.                 (class-name-of contact)))
  1784.       (translations (and (typep contact 'contact)
  1785.                  (slot-value (the basic-contact contact) 'event-translations))))
  1786.       ;; Print event-translations for the contact
  1787.       (dolist (event translations)
  1788.     (print-event contact event stream))
  1789.       
  1790.       ;; Print event-translations for the contact's class
  1791.       (dolist (event (get class 'event-translations))
  1792.     (unless (assoc (car event) translations :test #'equal)
  1793.       (print-event class event stream)
  1794.       (push event translations)))
  1795.       
  1796.       ;; Print event-translations for the contact's superclasses
  1797.       (dolist (class (class-all-superclasses class))
  1798.     (dolist (event (get class 'event-translations))
  1799.       (unless (assoc (car event) translations :test #'equal)
  1800.         (print-event class event stream)
  1801.         (push event translations)))))))
  1802.